home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / CGI shell / Pocket 6.4 / Extensions / Misc < prev   
Text File  |  1993-12-26  |  4KB  |  105 lines
  1. ( Misc extras for Pocket Forth 0.6.3 or 1.6.3 ) decimal
  2. 0 28 +md !
  3.  
  4. \ additional stack words
  5. : SP! ( -- ) s0@ ,$ 2C5E ;  ( move.l [ps]+,ps ) ( reset pstack )
  6. : NIP ( n1 n2 -- n2 ) ,$ 3C9E ; MACRO  ( move [ps]+,[ps] )
  7. : TUCK ( n1 n2 -- n2 n1 n2 ) swap over ;
  8. : 4+ ( n -- n+4 ) ,$ 5856 ; MACRO  ( addq #4,[ps] )
  9.  
  10. \ compiled strings
  11. : EVEN ( n -- n' ) \ dup 2 mod + ;  ( round up to even number )
  12.     ,$ 5256 ,$ 256 ,$ fffe ;
  13.  
  14. : ," ( -- ) ( compile a quoted string from input stream )
  15.     34 word here c@ 1+ even allot ; IMMEDIATE
  16.  
  17. \ return stack words: Used for extended toolbox support.
  18. : RP! ( -- ) r0@ ,$ 2E5E ;  ( move.l [ps]+,rs ) ( reset rstack )
  19. : 0>R  ( rstack: -- 0 ) ,$ 4267 ; MACRO ( clr -[rs] )
  20. : 00>R ( rstack: -- 0 0 ) ,$ 42A7 ; MACRO  ( clr.l -[rs] )
  21. : 2R ( -- d ) ( rstack: d -- d )
  22.     ,$ 2D17 ; MACRO  ( move.l [rs],-[ps] )
  23.  
  24. \ Some Mac interface stuff:
  25.  
  26. \ Call an alert from an _existing_ ALRT resource.
  27. \ Make it with ResEdit and add it to (a copy of) Pocket Forth.
  28. : .ALERT ( resource.ID -- dismissing.item.number )
  29.     0>r >r 00>r  ,$ a985  r> ;  ( _Alert )
  30.  
  31. \ Get the handle of an _existing_ resource.
  32. : REZ ( id type -- dhandle true or false )
  33.     00>r 2>r >r  ,$ A9A0  2r>  ( _GetResource )
  34.     2dup IF -1 ELSE drop THEN ;  ( leave error flag )
  35.  
  36. \ Run a subroutine from a handle to it.
  37. \ Nothing is saved, so make sure your external code does.
  38. \ See machine language section of Pocket Forth manual.
  39. : RUN ( dhandle -- )
  40.     dl@ ,$ 205E ,$ 4E90 ;  ( move.l [ps]+,a0  jsr [a0] )
  41.  
  42. \ Pick a random number from 0 to n
  43. : SEED ( -- daddr ) ,$ 2d15 126 0 dnegate d+ ;
  44. : TIME ( -- d ) 524 0 dl@ ;
  45. : RANDOMIZE time seed dl! ;
  46. : RANDOM ( n -- n' )
  47.     0>r ,$ A861  r> ( _Random )
  48.     swap 32768 */ abs ;  ( scale to size from stack )
  49.  
  50. \ Get the main screen's size in pixels.
  51. : SSIZE ( -- h v )  \ access a global (a5) variable
  52.     ,$ 2d2d ,$ ff8c ; MACRO  \ move.l screenBits(a5),-(a6)
  53.  
  54. \ color testing
  55. : ?COLOR ( -- f ) \ true if color is available and system>6.0.4
  56.     ,s qd   ?gestalt dup IF  2drop 256 < 0= THEN ; 
  57. : GDEVICE ( -- dhandle ) \ handle of grafics device
  58.     00>r ,$ aa32 2r> ;  ( _getGDevice )
  59. : BITS/PIXEL ( -- n )  \ n = bit depth of monitor setting
  60.     ?color IF
  61.       gdevice  dl@ 22 s>d d+  \ handle of pixmap
  62.       dl@ dl@ 32 s>d d+  l@   \ get the pixsize
  63.     ELSE 1 THEN ;
  64.  
  65. \ Put a character on the clipboard.
  66. : >CLIP ( c -- )
  67.     256 *  ( move ascii data into byte position )
  68.     00>r ,$ A9FC 2r> 2drop  ( _ZeroScrap )
  69.     00>r  1 0 2>r  ,s TEXT 2>r  sp@ 2>r  ,$ A9FE  ( _PutScrap )
  70.     2r> + IF beep THEN ;  ( beep on error )
  71.  
  72. : ?DA ( -- flag )  \ true if the Pocket Forth DA is running
  73.     0 +md 2@          ( the window's pointer )
  74.     108 0 d+ l@  0< ; ( the windowKind integer<0 if DA kind )
  75.  
  76. ( Display memory in hex )
  77. : H.2 ( n -- ) \ Print a hex number with at least 2 digits.
  78.     base @ >r hex  dup 16 < IF
  79.       0 . 8 emit THEN  .  r> base ! ;
  80. : A. ( addr -- ) h.2 8 emit ." :  " ;  \ print formatted addr
  81. : DUMP ( addr len -- )   \ Do a formatted hex dump of memory.
  82.     swap dup -16 and swap dup a.   ( next lower rounded addr )
  83.     over - dup 0 DO  space space space LOOP ."  |"  ( marker )
  84.     rot +  over cr a.  0 DO                ( number of lines )
  85.       dup r + c@ h.2      ( print byte value at addr + index )
  86.       r 1+ 16 mod 0= IF       ( If at end of 16 byte line... )
  87.         dup r + 1+ cr a. THEN LOOP     ( ...start a new line )
  88.     drop cr ;
  89.  
  90. ( Case by Randolph Peters of the University of Pennsylvania )  
  91. : CASE  0 ; IMMEDIATE           \ Example:
  92. : OF                             \  : SWITCH ( n -- )
  93.     [ ' over literal ] compile    \     case
  94.     [ ' =    literal ] compile     \      0 of ." Off" cr endof
  95.     [compile] if ; IMMEDIATE        \     1 of ." On" cr endof
  96. : ENDOF  [compile] else ; immediate  \    otherwise ." None"
  97. : OTHERWISE ; IMMEDIATE               \ endcase ;
  98. : ENDCASE
  99.     BEGIN  ?dup WHILE [compile] then  REPEAT
  100.     [ ' drop literal ] compile  ; IMMEDIATE
  101.  
  102. -1 28 +md !
  103. ( You have just loaded several utility words.)
  104. ( Examine them in the Misc file for more info)
  105.